home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / dejagnu.lha / dejagnu-1.0.1 / tcl / testsuite / config / unix-tcl.exp
Text File  |  1993-04-27  |  3KB  |  124 lines
  1. #   Copyright (C) 1988, 1990, 1991, 1992 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # bug-dejagnu@prep.ai.mit.edu
  19.  
  20. # This file was written by Rob Savoye. (rob@cygnus.com)
  21.  
  22. set testdrv "tclTest"
  23.  
  24. #
  25. # tcl_version -- extract and print the version number of tcl
  26. #
  27. proc tcl_version { } {
  28.     global testdrv
  29.     global subdir
  30.  
  31.     set version ""
  32.     catch {exec echo "info tclversion" | $testdrv} tmp
  33.     regexp "\[0-9\]\.\[0-9\.\]+" $tmp version
  34.     clone_output "Tcl library is version $version\n"
  35.     unset tmp
  36.     unset version
  37. }
  38.  
  39. #
  40. # tcl_load -- loads the program. For tcl, we just execute it
  41. #
  42. proc tcl_load { arg } {
  43.     global verbose
  44.     global exec_output
  45.     global subdir
  46.     global testdrv
  47.     global exec_output
  48.     global spawn_id
  49.  
  50.     if ![file exists $arg] then {
  51.     error "$arg does not exist."
  52.     return -1
  53.     }
  54.  
  55.     if $verbose>1 then {
  56.     send_user "Sourcing $arg...\n"
  57.     }
  58.     send "source $arg\n"
  59.     return 0
  60. }
  61.  
  62. #
  63. # tcl_exit -- exit the test driver for tcl
  64. #
  65. proc tcl_exit {} {
  66. }
  67.  
  68. #
  69. # tcl_start -- start the test driver for tcl
  70. #
  71. proc tcl_start { } {
  72.     global testdrv
  73.  
  74.     global objdir
  75.     global subdir
  76.     global srcdir
  77.     global verbose
  78.     global spawn_id
  79.     
  80.     set testdrv "$objdir/$testdrv"
  81.     set defs    "$srcdir/../tests/defs"
  82.  
  83.     spawn $testdrv
  84.     send "source $defs\n"
  85.     expect {
  86.     -re ".*source $defs.*$" {
  87.         verbose "Sourced $defs" 1
  88.         }
  89.     "Error: couldn't read file*" {
  90.         error "Couldn't source $defs"
  91.         return -1
  92.     }
  93.     "%" {
  94.         verbose "Sourced $defs" 1
  95.         return 0
  96.         }
  97.     timeout {
  98.         error "Timed out sourcing $defs."
  99.         return 1
  100.     }
  101.     }
  102.  
  103.     send "set VERBOSE 1\n"
  104.     expect {
  105.     -re "set VERBOSE 1.*1.*%" {
  106.         if $verbose>1 then {
  107.         send_user "Set verbose flag for tests\n"
  108.         }        
  109.     }
  110.     timeout {
  111.         error "Timed out setting verbose flag."
  112.     }
  113.     }
  114.     return $spawn_id
  115. }
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.